\ Component Object Module Interface
\ Tom Dixon
\ 8/16/2008

Vocabulary FCOM
also FCOM definitions


\ Interfaces

: search-iface ( str len interface -- addr -1 | 0 )
   over if
     begin @ ?dup while
       3dup 3 cells + count istr= 
       if nip nip true exit then
     repeat 2drop false
   else 
     2drop drop false 
   then ;


\ Simple parsing words
: parseword ( -- str len ) bl word count ;
: peek >in @ parseword rot >in ! ;
: skip-word parseword 2drop ;

: ComIFace ( interface -- ) 
   CREATE 0 , 16 + , IMMEDIATE
   DOES> 
   state @ if dup POSTPONE LITERAL then
   dup peek rot cell+ @ search-iface if 
     state @ if 
       COMPILE-INTERFACE 
     else 
       RUN-INTERFACE 
     then skip-word 
   then
   state @ if drop then ;

0 value openiface

: IMethod ( a n -- ) \ n is vtable index, a is num args
   here openiface 16 + @ , 
   openiface 16 + ! , ,
   here parseword dup 1+ allot rot place ;

: UCOM ( pointer -- ) \ call using an interface
   bl word find if 
     execute else count type err_NotIF ?throw 
   then
   peek rot 16 + search-iface if 
     state @ if 
       COMPILE-INTERFACE 
     else 
       RUN-INTERFACE 
     then 
     skip-word 
   then
  ; IMMEDIATE
  
  
: INTERFACE ( interface |guid -- )
   ?dup if 
     create guid, 16 + here over @ , swap !
   else 
     create guid, 0 , 
   then ;

: Open-Interface ( interface -- ) 
   to openiface ;
: Close-Interface ( -- ) 
   0 to openiface ;


\ define the unknown interface

0 Interface IUnknown    {00000000-0000-0000-C000-000000000046}
IUnknown Open-Interface
  3 0  IMethod IQueryInterface ( ppv riid -- hres )
  1 1  IMethod IAddRef ( -- refs )
  1 2  IMethod IReleaseRef (  -- refs )
Close-Interface

\ dispatch interface
IUnknown Interface IDispatch     {00020400-0000-0000-C000-000000000046}
IDispatch Open-Interface
  2 3  IMethod GetTypeInfoCount ( pctinfo -- hres )
  4 4  IMethod GetTypeInfo ( ppTInfo lcid iTInfo -- hres )
  6 5  IMethod GetIDsOfNames ( dispid lcid cnt uNames riid -- hres )
  9 6  IMethod Invoke ( argerr exinfo vres dispparams wflags lcid riid Idmem -- hres )
Close-Interface

UUID GUID_NULL {00000000-0000-0000-0000-000000000000}

\ **** AUTOMATION ****
\ this is the point where automation tries to control the rigors of
\ defining interfaces and types.

\ These are the three main type library interfaces
\ ITypeComp is the one we use most.

IUnknown Interface ITypeLib      {00020402-0000-0000-C000-000000000046}
IUnknown Interface ITypeInfo     {00020401-0000-0000-C000-000000000046}
IUnknown Interface ITypeComp     {00020403-0000-0000-C000-000000000046}

ITypeInfo Open-Interface \ define the interface
  2 3  IMethod GetTypeAttr ( TypeAttr -- hres )
  2 4  IMethod GetTypeComp ( ITypeComp -- hres )
  3 5  IMethod GetFuncDesc ( FuncDesc index -- hres )
  3 6  IMethod GetVarDesc  ( VarDesc index -- hres )
  5 7  IMethod GetNames ( pnames maxnames bstr memid -- hres )
  3 8  IMethod GetRefTypeOfImplType ( Hreftype index -- hres )
  3 9  IMethod GetImplTypeFlags ( flags index -- hres )
  4 10 IMethod GetIDsOfNames ( memid n bstr -- hres )
  8 11 IMethod Invoke ( argerr exceptinfo res DispParams flags memid pInst -- hres )
  6 12 IMethod GetDocumentation ( strfile context strdoc strname memid -- hres )
  6 13 IMethod GetDllEntry ( ordinal bstrname bstrdllname Kind memid -- hres )
  3 14 IMethod GetRefTypeInfo ( ITypeInfo Hreftype -- hres )
  4 15 IMethod AddressOfMember ( addr kind memid -- hres )
  4 16 IMethod CreateInstance ( pointer interface IUnknown -- hres )
  3 17 IMethod GetMops ( bstrmops memid -- hres )
  3 18 IMethod GetContainingTypeLib ( addr ITypelib -- hres )
  2 19 IMethod ReleaseTypeAttr ( TypeAttr -- n )
  2 20 IMethod ReleaseFuncDesc ( funcdesc -- n )
  2 21 IMethod ReleaseVarDesc ( vardesc -- n )
Close-Interface

ITypeLib Open-Interface \ define the typelib interface
  1 3  IMethod GetTypeInfoCount ( -- n )
  3 4  IMethod GetTypeInfo ( ITypeInfo index-- hres )
  3 5  IMethod GetTypeInfoType ( typekind index -- hres )
  3 6  IMethod GetTypeInfoOfGuid ( ITypeInfo guid -- hres )
  2 7  IMethod GetLibAttr ( TLibAttr -- hres )
  2 8  IMethod GetTypeComp ( ITypeComp -- hres )
  6 9  IMethod GetDocumentation ( bstrfile context bstrdoc bstrname index -- hres )
  4 10 IMethod IsName ( flag hashval bstrname -- hres )
  6 11 IMethod FindName ( found memid ITypeInfo hashval bstrname -- hres )
  2 12 IMethod ReleaseTLibAttr ( TlibAttr -- n )
Close-Interface

ITypeComp Open-Interface \ define the typecomp interface
  7 3  IMethod Bind ( bindptr desckind ptypeinfo wflags Hash uName -- hres )
  5 4  IMethod BindType ( ptypecomp ptypeinfo Hash uName -- hres )
Close-Interface


\ Error Handling Interfaces

IDispatch Interface ISupportErrorInfo   {DF0B3D60-548F-101B-8E65-08002B2BD119}
IUnknown  Interface IErrorInfo          {1CF2B120-547D-101B-8E65-08002B2BD119}
IUnknown  Interface ICreateErrorInfo    {22F03340-547D-101B-8E65-08002B2BD119}


ISupportErrorInfo Open-Interface
  2 7  IMethod InterfaceSupportErrorInfo ( riid -- hres )
Close-Interface

IErrorInfo Open-Interface
  2 3  IMethod GetGUID ( *GUID -- hres )
  2 4  IMethod GetSource ( bstrsource -- hres )
  2 5  IMethod GetDescription ( bstrdesc -- hres )
  2 6  IMethod GetHelpFile ( bstrfile -- hres )
  2 7  IMethod GetHelpContext ( n -- hres )
Close-Interface

ICreateErrorInfo Open-Interface
  2 3  IMethod SetGUID ( *GUID -- hres )
  2 4  IMethod SetSource ( bstrsource -- hres )
  2 5  IMethod SetDescription ( bstrdesc -- hres )
  2 6  IMethod SetHelpFile ( bstrfile -- hres )
  2 7  IMethod SetHelpContext ( n -- hres )
Close-Interface


: freeref ( iface -- ) \ frees a reference to an interface
   dup @ if 
     dup UCOM IUnknown IReleaseRef drop 
     0 swap ! 
   else 
     drop 
   then ;
   
: (freeref) ( iface -- ) \ frees an interface that is not in a variable
   LOCALS| iface |
   laddr iface freeref ;


\ Quick Structures - Not very usefull for anything but working with
\ Com Interface structures, I wanted something simple that would allow
\ levels of unions and stuff, so I made a quick structure thing.

\ structure type
: StructType ( size -- ) 
   create , 0 , ;

: StructSize ( structtype -- size ) 
   @ ;

: search-struct ( str len structtype -- addr -1 | 0 )
   over if
     begin @ ?dup while
       3dup 4 cells + count istr= if 
         nip nip true exit 
       then
     repeat 
     2drop false
   else 
     2drop drop false 
   then ;


: Struct ( structtype -- ) 
   create dup cell+ , @ allot IMMEDIATE
   does> 
   dup peek rot @ search-struct if 
     skip-word dup 3 cells + @ execute + cell+
     state @ if 
       POSTPONE LITERAL 
     then
   else 
     cell+ state @ if 
       POSTPONE LITERAL
     then 
   then ;

\ opens the structtype on any address
: USEStruct ( addr |structtype -- addr ) \ works like "using"
   bl word find if 
     execute 
   else 
     type err_NoValStruct ?throw
   then
   peek rot cell+ search-struct if 
     skip-word dup 3 cells + @ execute
     state @ if 
       POSTPONE LITERAL 
       POSTPONE + 
     else 
       + 
     then
   else 
     state @ if 
       POSTPONE LITERAL 
     then 
   then ;  IMMEDIATE

0 value openstruct

: field-xt ( addr -- n ) 
   cell+ @ ;

: struct-xt ( addr -- n ) 
   dup cell+ @ swap 2 cells + @
   peek rot cell+ search-struct if 
     skip-word dup 3 cells + @ execute + 
   then ;

: Field: ( offset |name -- ) \ makes an offset
   here openstruct cell+ @ , 
   openstruct cell+ ! , 0 , 
   ['] field-xt ,
   here parseword dup 1+ allot rot place ;

: Struct: ( offset structtype |name -- )
   here openstruct cell+ @ , 
   openstruct cell+ ! swap , , 
   ['] struct-xt ,
   here parseword dup 1+ allot rot place ;

: Open-Struct ( interface -- ) 
   to openstruct ;
   
: Close-Struct ( -- ) 
   0 to openstruct ;

\ Automation structures

\ VARIANT and VARIANTARG
16 StructType VARIANT  VARIANT open-struct
  0 field: vt
  2 field: wreserved1
  4 field: wreserved2
  6 field: wreserved3
  8 field: val  \ there are a Zillion different unions, just use val
close-struct

\ TYPEDESC structure
8 StructType TypeDesc  Typedesc open-struct
  0 field: lptdesc
  0 field: lpadesc
  0 field: hreftype
  4 field: vt
close-struct

\ IDLDESC structure
8 StructType IDLDESC  IDLDESC open-struct
  0 field: dwreserved
  4 field: wIDLFlags
close-struct

\ PARAMDESCEX structure
32 StructType PARAMDESCEX  ParamdescEx open-struct
  0 VARIANT struct: cbyte
  16 VARIANT struct: varDefaultValue
close-struct

8 StructType PARAMDESC  PARAMDESC open-struct
  0 field: pPARAMDescEx
  4 field: wPARAMFlags
close-struct


\ ELEMDESC structure
16 StructType elemdesc  elemdesc open-struct
  0 TypeDesc struct: tdesc
  8 IDLDESC  struct: idldesc
  8 PARAMDESC struct: paramdesc
close-struct

\ FUNCDESC structure
60 StructType FuncDesc  Funcdesc open-struct
  0 field: memid
  4 field: lprgscode
  8 field: lprgelemdescParam
  12 field: funckind
  16 field: invkind
  20 field: callconv
  24 field: cparams
  26 field: vparamsopt
  28 field: ovft
  30 field: cscodes
  32 ELEMDESC struct: elemdescFunc
  58 field: funcflags
close-struct

\ VARDESC structure
36 StructType VARDESC  vardesc open-struct
  0 field: memid
  4 field: lpstrSchema
  8 field: oInst
  8 field: lpvarValue
  12 ELEMDESC struct: elemdescVar
  28 field: wVarFlags
  32 field: varkind
close-struct

\ TYPEATTR structure
76 StructType TYPEATTR  TYPEATTR open-struct
  0 Field: guid
  16 field: lcid
  20 field: dwreserved
  24 field: memidConstructor
  28 field: memidDestructor
  32 field: lpstrSchema
  36 field: cbSizeInstance
  40 field: typekind
  44 field: cFuncs
  46 field: cVars
  48 field: cImplTypes
  50 field: cbSizeVft
  52 field: cbAlignment
  54 field: wTypeFlags
  56 field: wMajorVerNum
  58 field: wMinorVerNum
  60 TYPEDESC struct: tdescAlias
  68 IDLDESC struct: idldescType
close-struct

\ DISPPARAMS Structure
16 StructType DISPPARAMS  DISPPARAMS open-struct
   0 field: rgvarg              \ Array of arguments.
   4 field: rgdispidNamedArgs   \ Dispatch IDs of named arguments.
   8 field: cArgs               \ Number of arguments.
   12 field: cNamedArgs         \ Number of named arguments.
close-struct


\ FuncKind enumeration
0 constant FUNC_VIRTUAL
1 constant FUNC_PUREVIRTUAL
2 constant FUNC_NONVIRTUAL
3 constant FUNC_STATIC
4 constant FUNC_DISPATCH

\ typekind enumeration
0 constant TKIND_ENUM
1 constant TKIND_RECORD
2 constant TKIND_MODULE
3 constant TKIND_INTERFACE
4 constant TKIND_DISPATCH
5 constant TKIND_COCLASS
6 constant TKIND_ALIAS
7 constant TKIND_UNION
8 constant TKIND_MAX

\ VarKind enumeration
0 constant VAR_PERINSTANCE
1 constant VAR_STATIC
2 constant VAR_CONST
3 constant VAR_DISPATCH

\ Invoke Kind
1 constant INVOKE_FUNC
2 constant INVOKE_PROPERTYGET
4 constant INVOKE_PROPERTYPUT
8 constant INVOKE_PROPERTYPUTREF

\ Desckind enumeration
0 constant DESCKIND_NONE
1 constant DESCKIND_FUNCDESC
2 constant DESCKIND_VARDESC
3 constant DESCKIND_TYPECOMP
4 constant DESCKIND_IMPLICITAPPOBJ
5 constant DESCKIND_MAX

\ pre-defined data types used by COM interface descriptors:
0     constant VT_EMPTY      \ no data associated with this
1     constant VT_NULL       \ same as a regular NULL
16    constant VT_I1         \ 1 byte signed integer
17    constant VT_UI1        \ 1 byte unsigned integer
2     constant VT_I2         \ 2 bytes signed integer
18    constant VT_UI2        \ 2 bytes unsigned integer
3     constant VT_I4         \ 4 bytes signed integer
22    constant VT_INT        \ same as VT_I4 but with a different code (?? what on earth are these people thinking!!?!)
19    constant VT_UI4        \ 4 bytes unsigned integer
23    constant VT_UINT       \ same as VT_UI4 but with a different code (I can only suppose for clarity....)
20    constant VT_I8         \ 8 bytes signed integer
21    constant VT_UI8        \ 8 bytes unsigned integer
4     constant VT_R4         \ IEEE 32-bit floating-point number
5     constant VT_R8         \ IEEE 64-bit floating-point number
6     constant VT_CY         \ 8 byte two's complement integer (scaled by 10000, used for currency)
7     constant VT_DATE       \ 64-bit floating-point number representing the days since Dec. 31, 1899
8     constant VT_BSTR       \ pointer to Null-terminated unicode string--see unicode notes above
9     constant VT_DISPATCH   \ pointer to a IDispatch interface
11    constant VT_BOOL       \ boolean value
10    constant VT_ERROR      \ 32-bit number containing status code
13    constant VT_UNKNOWN    \ pointer to a IUnknown interface
64    constant VT_FILETIME   \ 64-bit FileTime structure (see win32 api)
30    constant VT_LPSTR      \ pointer to Null-terminated ansi string
31    constant VT_LPWSTR     \ pointer to Null-terminated unicode string
72    constant VT_CLSID      \ pointer to guid (or a clsid, or what-have-you)
71    constant VT_CF         \ pointer to a clip structure
65    constant VT_BLOB       \ 32-bit count of bytes followed by that number of bytes
70    constant VT_BLOBOBJECT \ a blob containing a serialize object
66    constant VT_STREAM     \ pointer to an IStream interface
68    constant VT_STREAMED_OBJECT \ same as stream, but contains an object
67    constant VT_STORAGE    \ pointer to an IStorage interface
69    constant VT_STORED_OBJECT   \ same as storage, but contains an object
14    constant VT_DECIMAL    \ a decimal structure
24    constant VT_VOID       \ void (results I suppose)
25    constant VT_HRESULT    \ standard return code
26    constant VT_PTR        \ pointer to something
27    constant VT_SAFEARRAY  \ safearray
28    constant VT_CARRAY     \ normal array type
29    constant VT_USERDEFINED \ user defined type
$1000 constant VT_VECTOR     \ array of types, pointer to count, then pointer to the array
$2000 constant VT_ARRAY      \ pointer to safearray
$4000 constant VT_BYREF      \ value is a reference
$8000 constant VT_RESERVED   \ reserved type
$FFFF constant VT_ILLEGAL    \ illigal variant
12    constant VT_VARIANT    \ type indicator followed by corresponding value
$FFF  constant VT_ILLEGALMASK \ Illegal variant mask.
$FFF  constant VT_TYPEMASK   \ used as a mask for vt_vector, array and what-not


: vt>Str ( vt -- str len )  \ for type to string conversion
   case
        0 of s" empty"          endof
        1 of s" null"           endof
        2 of s" h"              endof
        3 of s" n"              endof
        4 of s" f32"            endof
        5 of s" f64"            endof
        6 of s" d"              endof
        7 of s" date-d"         endof
        8 of s" bstr"           endof
        9 of s" IDispatch"      endof
       10 of s" error"          endof
       11 of s" bool"           endof
       12 of s" variant"        endof
       13 of s" IUnknown"       endof
       14 of s" decimal"        endof
       15 of s" 15"             endof
       16 of s" c"              endof
       17 of s" c"              endof
       18 of s" h"              endof
       19 of s" n"              endof
       20 of s" d"              endof
       21 of s" d"              endof
       22 of s" n"              endof
       23 of s" n"              endof
       24 of s" void"           endof
       25 of s" hres"           endof
       26 of s" ptr"            endof
       27 of s" safearray"      endof
       28 of s" carray"         endof
       29 of s" udef"           endof
       30 of s" lpstr"          endof
       31 of s" lpwstr"         endof
       64 of s" filetime-d"     endof
       65 of s" blob"           endof
       66 of s" IStream"        endof
       67 of s" IStorage"       endof
       68 of s" Streamedobj"    endof
       69 of s" Storedobj"      endof
       70 of s" Blobobj"        endof
       71 of s" clip"           endof
       72 of s" clsid"          endof
    $1000 of s" Vector"         endof
    $2000 of s" Array"          endof
    $4000 of s" byref"          endof
    $8000 of s" Reserved"       endof
    dup s>d TUCK DABS <# #S ROT SIGN #> rot
  endcase ;

: argcells ( VT -- #cells ) \ returns the number of cells needed for a vtype
   dup 5          = if drop 2 exit then
   dup 6          = if drop 2 exit then
   dup 7          = if drop 2 exit then
   dup 20         = if drop 2 exit then
   dup 21         = if drop 2 exit then
   dup 64         = if drop 2 exit then
   dup VT_VARIANT = if drop 4 exit then 
   drop 1 ;

\ typeinfo attributes
: tattr-allot ( itypeinfo -- typeattr ) \ allocates a typeattr structure from tinfo
   0 LOCALS| tattr tinfo |
   laddr tattr tinfo UCOM ITypeInfo GetTypeAttr drop tattr ;

: tattr-free ( itypeinfo typeattr -- ) \ frees a typeattr struct
   swap UCOM ItypeInfo ReleaseTypeAttr drop ;

: tinfo>kind ( itypeinfo -- typekind ) \ returns a typekind constant
   dup tattr-allot dup UseStruct TYPEATTR typekind @ -rot tattr-free ;

: tinfo>nfunc ( itypeinfo -- typekind ) \ returns number of functions
   dup tattr-allot dup UseStruct TYPEATTR cFuncs w@ -rot tattr-free ;

: tinfo>nvars ( itypeinfo -- typekind ) \ returns number of variables
   dup tattr-allot dup UseStruct TYPEATTR cVars w@ -rot tattr-free ;

: tinfo>size ( itypeinfo -- size ) \ returns structure size
   dup tattr-allot dup UseStruct TYPEATTR cbSizeInstance @ -rot tattr-free ;


\ function stuff
: arg>vt ( funcdesc n -- vt ) \ returns argument type
   swap usestruct funcdesc lprgelemdescParam @ swap
   elemdesc structsize * + usestruct elemdesc tdesc vt w@ ;

: Typedesc>n  ( typedesc -- vt n  ) \ returns type and how many times its "pointed"
   0 over usestruct typedesc vt w@
   dup VT_PTR = if 
     drop 1+ swap usestruct typedesc lptdesc @ 
     recurse rot +
   else 
     swap rot drop 
   then ;

: arg. ( funcdesc n -- ) \ prints an argument
   swap usestruct funcdesc lprgelemdescParam @ 
   swap elemdesc structsize * +
   usestruct elemdesc tdesc typedesc>n 
   0 ?do 
     42 emit 
   loop 
   vt>str type ;

: argsize ( funcdesc -- n ) \ returns size (in cells) of arguments
   dup UseStruct FuncDesc cparams w@ 0 swap 
   0 ?do 
     over i arg>vt argcells + 
   loop 
   nip ;
   
: funcoff ( funcdesc -- offset ) \ returns offset into vtable ( bytes )
   UseStruct FuncDesc oVft w@ ;

\ constant stuff
: varinst ( vardesc -- n ) \ returns constant or (if its a structure) an offset
   dup UseStruct VarDesc varkind @ case
           VAR_CONST of UseStruct VarDesc oInst @ 
                        UseStruct Variant Val @ 
                     endof
     VAR_PERINSTANCE of UseStruct VarDesc oInst @ 
                     endof
                     drop -1 
   endcase ;

\ binding words

: >bindtype ( ustr tcomp -- tinfo ) \ returns the ITypeinfo of ustr
   0 0 LOCALS| tinfo tcomp |
   laddr tcomp laddr tinfo 2swap 0 -rot 
   UCOM ITypeComp BindType err_InvBind ?throw
   laddr tcomp freeref tinfo ;

: binder ( ustr tcom invoke -- buf tinfo kind ) 
   0 0 0 LOCALS| buf tinfo kind invoke tcomp ustr |
   laddr buf laddr kind laddr tinfo invoke 0 ustr
   tcomp UCOM ITypeComp Bind err_Bind ?throw
   buf tinfo kind ;

: >bind ( ustr tcomp -- buf tinfo kind ) \ returns a typeinfo, desckind, and a buffer
   0 binder ;

: >bindf ( ustr tcomp -- buf tinfo kind ) \ returns a typeinfo, desckind, and a buffer
   INVOKE_FUNC binder ;

: >bindg ( ustr tcomp -- buf tinfo kind ) \ returns a typeinfo, desckind, and a buffer
   INVOKE_PROPERTYGET binder ;

: >bindp ( ustr tcomp -- buf tinfo kind ) \ returns a typeinfo, desckind, and a buffer
   INVOKE_PROPERTYPUT binder ;

: >bindpr ( ustr tcomp -- buf tinfo kind ) \ returns a typeinfo, desckind, and a buffer
   INVOKE_PROPERTYPUTREF binder ;


\ These words are for "dumping" interfaces and structures so you don't have
\ to look at documentation as much while you are programming
\ They aren't as "thread-safe" as everything else in this Module, but I don't
\ think they need to be just to see what an interface has got.

create tbuf 256 allot
0 value vargs
0 value argtypei

: typedocs ( tinfo -- ) \ note that this modifies tbuf a lot - also expects typeattr in tbuf
   dup >r tbuf 4 + dup 4 + dup 4 + dup 4 + tbuf @ @
   r> UCOM ITypeInfo GetDocumentation drop ;
   
: typedocs-free ( -- ) 
   tbuf 4  + @ bstrFree
   tbuf 8  + freeref
   tbuf 12 + @ bstrFree
   tbuf 16 + @ bstrFree ;
   
: stars ( n -- ) 0 ?do 42 emit loop ; \ Hey!  Right out of Starting Forth!

: Typedesc>type ( typedesc -- ) \ prints a typedesc var to the screen
   0 0 LOCALS| rtinfo tstr |
   dup typedesc>n over VT_USERDEFINED <> argtypei 0= or if 
     stars vt>str type drop
   else 
     dup stars nip 0 ?do 
       usestruct typedesc lptdesc @ 
     loop 
     laddr rtinfo swap usestruct typedesc hreftype @ 
     argtypei UCOM ITypeinfo Getreftypeinfo drop
     0 0 0 laddr rtinfo laddr tstr -1 rot 
     UCOM ITypeinfo GetDocumentation drop
     tstr zunicount unitype tstr bstrfree 
     laddr rtinfo freeref
     0 to argtypei 
   then ;

: .sfieldtype ( tinfo -- ) \ prints out the data type of the field
   typedocs
   tbuf 16 + @ zunicount unitype space ." \ (" dup to argtypei
   tbuf @ usestruct vardesc elemdescvar tdesc typedesc>type ." ) "
   tbuf 12 + @ ?dup if 
     zunicount unitype 
   then 
   typedocs-free ;

: arg>str ( funcdesc n -- ) \ prints an argument to the screen
   swap usestruct funcdesc lprgelemdescParam @ 
   swap elemdesc structsize * + 
   usestruct elemdesc tdesc typedesc>type ;

: .methods ( typeinfo -- ) 
   0 LOCALS| rtinfo | 
   0 tbuf ! dup tbuf 0 rot UCOM ITypeinfo GetRefTypeofImplType drop
   tbuf @ if 
     dup laddr rtinfo tbuf @ rot 
     UCOM ITypeinfo GetRefTypeinfo drop
     laddr rtinfo recurse 
     laddr rtinfo freeref
   else 
     drop exit 
   then
   dup tinfo>nfunc 
   0 ?do 
     2 spaces 0 to vargs
     dup tbuf i rot UCOM ITypeInfo getfuncdesc drop 
     tbuf @ usestruct funcdesc cparams w@ 
     0 ?do 
       tbuf @ i arg>vt argcells vargs + to vargs 
     loop 
     1 vargs + dup to vargs . 
     tbuf @ usestruct funcdesc oVft w@ 4 / . ."  IMethod " 
     tbuf @ usestruct funcdesc invkind @ case
       INVOKE_PROPERTYGET    of ." Get"    endof
       INVOKE_PROPERTYPUT    of ." Put"    endof 
       INVOKE_PROPERTYPUTREF of ." PutRef" endof
     endcase
     dup 0 0 rot 0 tbuf 4 + rot tbuf @ @ swap 
     UCOM ITypeinfo getdocumentation drop 
     tbuf 4 + @ zunicount unitype space ." ( " 
     tbuf @ usestruct funcdesc cparams w@ 
     0 ?do 
       dup to argtypei tbuf @ dup 
       usestruct funcdesc cparams w@ i - 1- 
       arg>str space 
     loop 
     ." -- " 
     tbuf @ usestruct funcdesc elemdescfunc tdesc vt w@ vt>str type ."  )" cr 
     tbuf @ over UCOM ITypeInfo releasefuncdesc drop 
   loop 
   drop ;

: .sfield ( typeinfo -- ) \ types the fields in a structure
   tbuf over UCOM ITypeinfo gettypeattr drop
   tbuf @ usestruct typeattr cvars @
   over tbuf swap UCOM ITypeinfo releasetypeattr drop
   0 ?do
     dup tbuf i rot UCOM ITypeinfo getvardesc drop
     tbuf @ usestruct vardesc varkind @ VAR_PERINSTANCE = if 
       2 spaces
       tbuf @ usestruct vardesc elemdescvar tdesc vt w@ VT_USERDEFINED = if 
         tbuf @ usestruct vardesc oInst @ .
         dup tbuf @ usestruct vardesc elemdescvar tdesc hreftype @
         tbuf 4 + swap rot UCOM ITypeinfo GetRefTypeinfo drop
         0 0 0 tbuf 8 + -1 tbuf 4 + UCOM ITypeinfo GetDocumentation drop
         tbuf 12 + tbuf 4 + UCOM Itypeinfo gettypeattr drop
         tbuf 12 + @ usestruct typeattr cbSizeInstance @
         tbuf 12 + @ tbuf 4 + UCOM Itypeinfo releasetypeattr drop
         4 > if
           tbuf 8 + @ zunicount unitype 
           tbuf 4 + freeref 
           ."  Struct: " 
         else
           ." Field: " 
           tbuf 4 + freeref 
         then
         .sfieldtype
       else
         tbuf @ usestruct vardesc oInst @ . 
         ." Field: "
         .sfieldtype
       then cr
       tbuf over UCOM ITypeinfo releasevardesc drop
     then 
   loop 
   drop ;

: .consts ( typeinfo -- ) \ list all constants in an Enumeration
   tbuf over Ucom ITypeinfo gettypeattr drop
   tbuf @ usestruct typeattr cvars w@
   over tbuf swap UCOM ITypeinfo releasetypeattr drop
   0 ?do
     dup tbuf i rot UCOM ITypeinfo getvardesc drop
     tbuf @ usestruct vardesc varkind @ VAR_CONST = if 
       dup >r 0 0 0 tbuf 4 + tbuf @ @ r> 
       UCOM ITypeInfo GetDocumentation drop
       tbuf 4 + @ zunicount unitype cr
       tbuf over Ucom ITypeinfo releasevardesc drop
     then 
   loop 
   drop ;
   
: globaltype ( type typelib -- )
   dup UCOM ITypeLib GetTypeInfoCount 
   0 ?do
     2dup tbuf i rot UCOM ITypeLib GetTypeInfoType 
     err_GetTypeInfo ?throw
     tbuf @ = if
       dup 0 0 rot 0 tbuf rot i swap UCOM ITypeLib GetDocumentation
       err_GetDoc ?throw 
       tbuf @ zunicount unitype cr
     then
   loop 
   2drop ;


create typelibhead 0 ,

: typelib ( major minor | guid -- ) \ load a type library into the list
   here >r typelibhead @ , 
   here dup >r 0 , here 0 , 
   2swap swap here guid, fLoadRegTypeLib
   err_LoadTypeLib ?throw
   r> dup cell+ swap UCOM ITypeLib GetTypeComp 
   err_GetTypeComp ?throw
   r> typelibhead ! ;

: typelibfile ( str len -- ) \ load a type library from a file
   >unicode drop here >r typelibhead @ ,
   here dup >r 0 , 0 , swap fLoadTypeLib
   err_LoadTypeLib ?throw 
   r> dup cell+ swap UCOM ITypeLib GetTypeComp
   err_GetTypeComp ?throw 
   r> typelibhead ! ;
   
: globaldump ( tkind -- ) 
   cr typelibhead
   begin @ dup while
     2dup cell+ globaltype 
   repeat 
   2drop ;
   
: CoClasses ( -- ) \ print a list of all available coclasses
   TKIND_COCLASS globaldump ;

: Interfaces ( -- ) \ print a list of all available interfaces
   TKIND_INTERFACE globaldump
   TKIND_DISPATCH globaldump ;

: Structures ( -- ) \ print a list of all available structures
   TKIND_RECORD globaldump ;

: ComConsts ( -- ) \ print a list of all constants
   TKIND_ENUM globaldump ;


create tfind 256 allot

: get-next ( tcomp -- buf tinfo kind ) \ if kind = -1, then tinfo is a nested struct
   tfind count >unicode drop
   2dup swap >bind ?dup if 
     >r 2swap 2drop r> 
     parseword tfind place exit 
   then
   2drop swap >bindtype ?dup if 
     0 swap -1 parseword tfind place exit 
   then
   0 0 0 ;

: constbind ( vardesc tinfo -- n ) \ constants
   (freeref)
   dup varinst swap fCoTaskMemFree ;

: varbind ( vardesc tinfo -- n ) \ both structures and constants
   over UseStruct VarDesc varkind @
   dup VAR_CONST = swap VAR_PERINSTANCE = or if
     constbind 
   else 
     2drop 0 
   then ;

: funcbind ( obj funcdesc tinfo -- ) \ function
   (freeref)
   dup funcoff swap fCoTaskMemFree
   state @ if COMPILE-VTABLE else RUN-VTABLE then ;

: >allbind ( tcomp -- buf tinfo kind )
   dup peek >unicode drop swap >bindf ?dup if 
     2swap nip -rot exit 
   else 
     2drop 
   then
   peek drop 3 s" Get" istr= if 
     peek 3 /string >unicode drop swap >bindg exit 
   then
   peek drop 6 s" PutRef" istr= if 
     peek 6 /string >unicode drop swap >bindpr exit 
   then
   peek drop 3 s" Put" istr= if 
     peek 3 /string >unicode drop swap >bindp exit 
   then
   drop 0 0 0 ;

: do-ciface ( ptr itypecomp -- )
   >allbind DESCKIND_FUNCDESC = if 
     bl word drop funcbind exit 
   then
   (freeref)
   ?dup if fCoTaskMemFree then ;

: ciface ( tinfo -- ) \ creates an interface pointer object
   LOCALS| tinfo |
   create 0 , here 0 , 
   laddr tinfo UCOM ITypeinfo GetTypeComp drop
   laddr tinfo freeref IMMEDIATE
   Does> dup state @ if 
     POSTPONE LITERAL 
   then 
   cell+ do-ciface ;

: nested-struc? ( vardesc -- htyperef )
   dup usestruct vardesc elemdescvar tdesc vt w@ 
   VT_USERDEFINED = if
     usestruct vardesc elemdescvar tdesc hreftype @ 
   else 
     drop 0 
   then ;

: do-struct ( offset itypecomp -- offset )
   0 0 0 LOCALS| rtinfo tinfo tcomp |
   peek >unicode drop swap >bind
   DESCKIND_VARDESC = if 
     bl word drop
     over nested-struc? ?dup if
       laddr rtinfo swap rot to tinfo
       laddr tinfo UCOM ITypeInfo GetRefTypeInfo drop
       laddr tinfo freeref
       dup varinst swap fCoTaskMemFree +
       laddr tcomp laddr rtinfo UCOM ITypeInfo GetTypeComp drop
       tcomp recurse
       laddr tcomp freeref
       laddr rtinfo freeref exit
     else 
       constbind + exit 
     then 
   then
   (freeref) 
   ?dup if fCoTaskMemFree then ;

: CStruct ( tinfo -- ) \ creates a structure from a com typeinfo iface
   LOCALS| tinfo | 
   peek s" Words" istr= if 
     bl word drop laddr tinfo .sfield
     laddr tinfo freeref exit 
   then
   create here 0 , swap 
   laddr tinfo UCOM ITypeInfo GetTypeComp drop
   laddr tinfo tinfo>size allot 
   laddr tinfo freeref IMMEDIATE
   Does> dup cell+ 0 rot do-struct + 
   state @ if 
     POSTPONE LITERAL
   then ;

: cguid ( tinfo -- ) \ compiles a guid
   LOCALS| tinfo | 
   laddr tinfo tattr-allot dup UseStruct TYPEATTR guid
   state @ if 
     16 POSTPONE SLITERAL POSTPONE DROP
   else 
     16 pad dup >r place r> 1+ 
   then
   laddr tinfo swap tattr-free 
   laddr tinfo freeref ;

: do-tinterface ( tinfo -- )
   LOCALS| tinfo |
   peek s" ComIFace" istr= if 
     bl word drop tinfo ciface exit 
   then
   peek s" Words" istr= if 
     bl word drop laddr tinfo .methods
     laddr tinfo freeref exit then
   tinfo cguid ;

: do-tdispatch ( tinfo -- )
   0 0 LOCALS| rtinfo rtype tinfo |
   laddr rtype -1 laddr tinfo
   UCOM ITypeInfo GetRefTypeOfImplType err_NoVI ?throw
   laddr rtinfo rtype laddr tinfo
   UCOM ITypeInfo GetRefTypeInfo err_NoVI ?throw
   laddr tinfo freeref 
   laddr rtinfo tattr-allot dup UseStruct TYPEATTR wTypeFlags w@ $40 and
   swap laddr rtinfo swap tattr-free if 
     peek s" ComIFace" istr= if
       bl word drop rtinfo ciface exit
     then
     peek s" Words" istr= if
       bl word drop laddr rtinfo .methods
       laddr rtinfo freeref exit
     then 
     rtinfo cguid
   else
     rtinfo cguid
   then ;
   
: Do-TypeLib ( tcomp -- flag ) \ performs the function of the typelib stuff
   0 LOCALS| tinfo | 
   tfind count >unicode drop swap 2dup >bind 
   DESCKIND_VARDESC = if 
     2swap 2drop constbind
     state @ if 
       POSTPONE LITERAL discard-sinline 
     then 
     true exit 
   then
   (freeref)
   ?dup if fCoTaskMemFree then
   >bindtype ?dup if to tinfo
     tinfo laddr tinfo tinfo>kind case
       TKIND_INTERFACE of do-tinterface true endof
       TKIND_DISPATCH  of do-tdispatch true endof
       TKIND_COCLASS   of cguid true endof
       TKIND_RECORD    of cstruct true endof
       TKIND_ENUM      of drop laddr tinfo .consts laddr tinfo freeref true endof
       laddr tinfo freeref drop false exit
     endcase 
   else 
     false 
   then ;

\ Here is where we make the typelibraries appear "global"

: istype? ( str len tcomp -- flag )
   -rot >unicode drop 2dup swap >bind -rot
   (freeref) 
   ?dup if fCoTaskMemFree then
   dup DESCKIND_IMPLICITAPPOBJ = if 
     DESCKIND_IMPLICITAPPOBJ - 
   then
   ?dup if 
     dup DESCKIND_VARDESC = swap DESCKIND_TYPECOMP = or if 
       2drop true exit 
     else 
       2drop false exit 
     then 
   then
   swap >bindtype dup 0<> swap (freeref) ;

variable typelibraries

: ?typelib ( c-addr len -- flag )
   typelibraries @ 0= if 
     2drop false exit 
   then
   typelibhead begin @ dup while 
     dup 2 cells + 2over rot istype? if 
       2 cells + -rot tfind place do-typelib exit 
     then
   repeat nip nip ;

' ?typelib is COMsearcher

\ Late-Binding for Types in typelibraries (needed only for interfaces and structures)

: do-late-tcomp ( ptr typecomp kind -- )
   case 
     TKIND_INTERFACE of do-ciface endof
     TKIND_DISPATCH  of do-ciface endof
     TKIND_RECORD    of 0 swap do-struct state @ if 
                          POSTPONE LITERAL POSTPONE + 
                        else 
                          + 
                        then 
                     endof
     2drop 
   endcase ;

: do-late ( tinfo -- )
   0 0 LOCALS| rtype rtinfo tinfo | 
   laddr tinfo tinfo>kind
   TKIND_DISPATCH = if
     laddr rtype -1 laddr tinfo
     UCOM ITypeInfo GetRefTypeOfImplType err_NoVI ?throw
     laddr rtinfo rtype laddr tinfo
     UCOM ITypeInfo GetRefTypeInfo err_NoVI ?throw
     laddr tinfo freeref
   then
   laddr tinfo laddr rtinfo UCOM ITypeInfo GetTypeComp drop
   laddr tinfo laddr rtinfo tinfo>kind do-late-tcomp
   laddr tinfo freeref
   laddr rtinfo freeref ;
   

: COM ( | name -- ... ) \ followed by Interface or structure
   peek tfind place tfind find if  \ old style interface
     execute bl word drop peek rot 16 + search-iface if 
       state @ if 
         COMPILE-INTERFACE 
       else 
         RUN-INTERFACE 
       then 
       bl word drop 
     then
   else          \ automated interface
     drop typelibhead 
     begin @ dup while
       dup 2 cells + peek rot istype? if 
         2 cells + parseword 2dup tfind place 
         >unicode drop swap >bindtype
         do-late exit 
       then
     repeat 
     0= err_NotIF ?throw
   then ; IMMEDIATE

typelibraries on

: free-lasttypelib ( -- ) \ frees the last type library
   typelibhead @ ?dup if
     dup @ typelibhead !
     dup cell+ freeref
     2 cells + freeref 
   then ;

: freetypelibs ( -- )
   typelibhead begin @ dup while
     dup cell+ freeref
     dup 2 cells + freeref 
   repeat
   drop 0 typelibhead ! ;

' freetypelibs AtExit

: com_init 0 fCoInitialize drop ;
' com_init AtCold  com_init


\ IDispatch Calling Interface
\ This is for calling methods in the IDispatch Interface.
\ It is a nasty calling convention that uses run-time type checking, passes arguments
\ through a bloated structure, and is slow.  Avoid these interfaces if possible.

\ The way to deal with it here is to pass argments on to a typed stack

16 CONSTANT maxvt \ Height of Stack

create VTstack  16 maxvt * allot \ stack
create VTNStack DISPID_PROPERTYPUT ,

DISPPARAMS Struct DispCall \ calling structure
  vtstack  DispCall rgvarg !
  vtnstack Dispcall rgdispidNamedArgs !

VARIANT Struct RetVT \ return value - only one allowed :-(


: vt@ ( addr -- n VT )
   dup w@ swap 8 + over argcells 2 = if 
     2@ rot 
   else 
     @ swap 
   then ;
: vt! ( n VT addr -- )
   2dup w! 8 + swap argcells 2 = if 
     2! 
   else 
     ! 
   then ;

: VT> ( -- n VT ) \ pop virtual type off stack
   DispCall cargs @ ?dup if 
     1- dup DispCall cargs !
     16 * DispCall rgvarg @ + vt@
   else 
     0 VT_EMPTY 
   then ;

: >VT ( n VT -- ) \ push Virtual Type onto Stack
   DispCall cargs @ dup maxvt < if
     16 * DispCall rgvarg @ + vt! 
     1 DispCall cargs +!
   else 
     err_VarStFull throw 
   then ;

: .vt ( -- ) 
   DispCall cargs @ 0 ?do
     DispCall rgvarg @ i 16 * + 
     vt@ dup vt>str type ." : "
     argcells 2 = if d. else . then 
   loop ;

: retVT@ ( -- n VT ) 
   RetVT vt@ ;


variable disperr

: DispatchCall ( type ID Interface -- hres ) \ Call IDispatch Invoke method
   2>r >r disperr 0 RetVT DispCall 
   r> 0 GUID_NULL 2r> UCOM IDispatch Invoke
   0 DispCall cargs ! 
   0 DispCall cnamedargs ! ;

: GetDispID ( ustr Interface -- ID ) \ Get Dispatch ID
   swap LOCALS| ustr | 
   laddr ustr swap disperr 
   0 2swap 1 -rot GUID_NULL swap
   UCOM IDispatch GetIDsOfNames if 
     0 
   else 
     disperr @ 
   then ;

: methkind ( str len -- ustr kind )
   over 6 s" PutRef" Istr= if 
     3 /string >unicode drop INVOKE_PROPERTYPUTREF
     1 DispCall cnamedargs ! 
     exit 
   then
   over 3 s" Put" Istr= if 
     3 /string >unicode drop INVOKE_PROPERTYPUT
     DISPID_PROPERTYPUT VTNStack !
     1 DispCall cnamedargs ! 
     exit 
   then
   over 3 s" Get" Istr= if 
     3 /string >unicode drop INVOKE_PROPERTYGET 
     exit 
   then
   >unicode drop INVOKE_FUNC ;

: .dispwords ( interface -- )
   0 LOCALS| tinfo |
   laddr tinfo 0 rot 0 swap 
   UCOM IDispatch GetTypeInfo err_CantDispatch ?throw
   laddr tinfo .methods 
   laddr tinfo freeref ;


: Do-Disp ( interface -- hres ) \ behavior of a dispatcher
   peek s" Words" Istr= if 
     .dispwords skip-word exit 
   then
   dup peek methkind swap rot getdispID dup 0= if 
     2drop state @ if 
       POSTPONE LITERAL
     then 
     exit 
   else 
     rot skip-word 
   then
   state @ if 
     rot POSTPONE LITERAL swap 
     POSTPONE LITERAL 
     POSTPONE LITERAL 
     POSTPONE DispatchCall
   else 
     DispatchCall 
   then ;

: Dispatcher ( <name> <progID> -- )
   create here 0 , here dup parseword >unicode drop fCLSIDFromProgID
   err_NoProgID ?throw
   IDispatch swap CLSCTX_SERVER 0 rot fCoCreateInstance 
   err_NoIUnknown ?throw
   IMMEDIATE 
   does> do-disp ;

: do-displate ( interface interface str len -- hres ) \ bind by string, not by ID
   methkind swap rot getdispID rot DispatchCall ;

: DispLate" ( interface <method> -- hres ) \ late-late bound dispatch
   state @ if 
     POSTPONE dup 
     [char] " parse
     POSTPONE SLITERAL 
     POSTPONE do-displate
   else 
     dup [CHAR] " parse 
     do-displate 
   then ; IMMEDIATE

previous definitions
